;;;;;
;;;;; Minimal .NET-like object system
;;;;;

;;;;
;;;; CLASSES
;;;;

(define-record-type class :class
  (%make-class name
	       parent ancestors
	       constructor
	       fields methods vtable
	       subclasses
	       type-object)
  class?
  (name class-name)
  (parent class-parent)
  (ancestors class-ancestors set-class-ancestors!)
  (constructor class-constructor set-class-constructor!)
  (fields class-fields)
  (field-default-values class-field-default-values
			set-class-field-default-values!)
  (methods class-methods set-class-methods!)
  (vtable class-vtable)
  (subclasses class-subclasses set-class-subclasses!)
  (type-object class-type-object set-class-type-object!))

(define-record-discloser :class
  (lambda (c)
    (list 'class (class-name c))))

(define (make-class name parent constructor-args fields methods)
  (set! parent (or parent object))
  (let* ((fields (append (class-fields parent)
			 fields))
	 (methods (append (class-methods parent)
			  methods))
	 (class (%make-class name parent '() #f fields methods
			     (make-vector (length methods) #f)
			     '()
			     #f)))
    (when constructor-args
      (set-class-constructor! class
			      (make-constructor class constructor-args)))
    ;; Set up bookkeeping info
    (set-class-ancestors! class (cons class (class-ancestors parent)))
    (set-class-subclasses! parent
			   (cons class
				 (class-subclasses parent)))
    (set-class-field-default-values! class
				     (map field-default-value
					  fields))
    ;; Copy over parent's vtable
    (let ((cvt (class-vtable class))
	  (pvt (class-vtable parent)))
      (dotimes (i (vector-length pvt))
	(vector-set! cvt i
		     (vector-ref pvt i))))
    class))

;;;;
;;;; FIELDS
;;;;

(define-record-type field :field
  (make-field name type default-value keywords)
  (name field-name)
  (type field-type)
  (keywords field-keywords)
  (default-value field-default-value))

(define-record-discloser :field
  (lambda (f)
    (list 'field (field-name f))))

(define-syntax field-info
  (syntax-rules ()
    ((field-info (?name ?other-args ...))
     (field-specifier (?other-args ...) ?name #f #f '()))
    ((field-info ?name)
     (field-specifier () ?name #f #f '()))))

(define-syntax field-specifier
  (syntax-rules (type: default: static virtual public)
    ((field-specifier (type: ?t ?other-args ...) ?name #f ?default ?keys)
     (field-specifier (?other-args ...) ?name ?t ?default ?keys))
    ((field-specifier (default: ?default ?other-args ...) ?name ?type #f ?keys)
     (field-specifier (?other-args ...) ?name ?type ?default ?keys))
    ((field-specifier static ?name ?type ?default (?keys ...))
     (field-specifier '?name '?type ?default (static ?keys ...)))
    ((field-specifier virtual ?name ?type ?default (?keys ...))
     (field-specifier '?name '?type ?default (virtual ?keys ...)))
    ((field-specifier public ?name ?type ?default (?keys ...))
     (field-specifier '?name '?type ?default (public ?keys ...)))
    ((field-specifier () ?name ?type ?default ?keys)
     (make-field '?name '?type ?default '?keys))
    ))

;;;;
;;;; FIELD ACCESS
;;;;

(define field-table '())

(define (field-index fieldname class)
  (or (list-index (lambda (field)
		    (eq? (field-name field)
			 fieldname))
		  (class-fields class))
      (error "No such field defined in class" fieldname class)))

(define (fast-object-accessor class fieldname)
  (let* ((field-index (field-index fieldname class))
	 (accessor
	  (lambda (object)
	    (if (is? object class)
		(vector-ref (object-fields object)
			    field-index)
		(error "Argument is not an object of class" class object)))))
    accessor))

(define (general-object-accessor fieldname)
  (define accessor
    (lambda (object)
      (vector-ref (object-fields object)
		  (field-index fieldname (object-class object)))))
  accessor)

(define (object-accessor class fieldname)
  (define probe (assq fieldname field-table))
  (if probe
      (or (memq class (cdr probe))
	  (set-cdr! probe
		    (cons class (cdr probe))))
      (set! field-table
	    (cons (list fieldname class)
		  field-table)))
  (if (and probe
	   (> (length probe) 2))
      (general-object-accessor fieldname)
      (fast-object-accessor class fieldname)))

(define (set-field! object fieldname value)
  (vector-set! (object-fields object)
	       (field-index fieldname (object-class object))
	       value)
  ;; This is just to defeat tail-recursion for debugging purposes.
  value)

;; Slow!
(define-syntax set
  (syntax-rules ()
    ((set (field object) value)
     (set-field! object 'field value))))

(define (object-generic class methodname)
  (define index (method-index methodname class))
  (define call-generic
    (lambda (object . args)
      (if (is? object class)
	  (apply (or (vector-ref (object-vtable object)
				 index)
		     (error "No method defined"
			    methodname
			    (object-class object)))
		 object
		 args)
	  (error "Must be an object of class" class object))))
  call-generic)

;;;;
;;;; METHODS
;;;;

(define-record-type method :method
  (make-method name type definition keywords)
  (name method-name)
  (type method-type)
  (keywords method-keywords)
  (definition method-definition))

(define-record-discloser :method
  (lambda (f)
    (list 'method (method-name f))))

(define-syntax method-info
  (syntax-rules ()
    ((method-info (?name ?other-args ...))
     (method-specifier (?other-args ...) ?name #f #f ()))
    ((method-info ?name)
     (method-specifier () ?name #f #f '()))))

(define-syntax method-specifier
  (syntax-rules (type: definition: static virtual public)
    ((method-specifier (type: ?t ?other-args ...) ?name #f ?definition ?keys)
     (method-specifier (?other-args ...) ?name ?t ?definition ?keys))
    ((method-specifier (definition: ?definition ?other-args ...) ?name ?type #f ?keys)
     (method-specifier (?other-args ...) ?name ?type ?definition ?keys))
    ((method-specifier static ?name ?type ?definition (?keys ...))
     (method-specifier ?name ?type ?definition (static ?keys ...)))
    ((method-specifier virtual ?name ?type ?definition (?keys ...))
     (method-specifier ?name ?type ?definition (virtual ?keys ...)))
    ((method-specifier public ?name ?type ?definition (?keys ...))
     (method-specifier ?name ?type ?definition (public ?keys ...)))
    ((method-specifier () ?name ?type ?definition ?keys)
     (make-method '?name '?type ?definition '?keys))
    ))

;;;;
;;;; METHOD ACCESS
;;;;

(define (method-index methodname class)
  (or (list-index (lambda (method)
		    (eq? (method-name method)
			 methodname))
		  (class-methods class))
      (error "No such operation defined on class" methodname class)))

(define (set-method! class methodname new-method)
  (define index (method-index methodname class))
  (let ((old-binding (vector-ref (class-vtable class) index)))
    (let update ((c class))
      (vector-set! (class-vtable c) index new-method)
      (for-each (lambda (subclass)
		  (let ((vt (class-vtable subclass)))
		    (if (eq? (vector-ref vt index)
			     old-binding)
			(update subclass))))
		(class-subclasses c)))))

;;;;
;;;; OBJECTS
;;;;

(define-record-type object :object
  (%make-object class fields)
  object?
  (class object-class)
  (fields object-fields))

(define-record-discloser :object
  (lambda (o)
    (list (class-name (object-class o)))))

(define-record-discloser :object
  (lambda (o)
    (let* ((class (object-class o))
	   (fields (class-fields class))
	   (name-index (list-index (lambda (field)
				     (eq? (field-name field)
					  'name))
				   fields)))
      (if name-index
	  (list (class-name (object-class o))
		(vector-ref (object-fields o)
			    name-index))
	  (list (class-name (object-class o)))))))

(define (object-vtable x)
  (class-vtable (object-class x)))

(define (object-ancestors object)
  (class-ancestors (object-class object)))

(define (is? object class)
  (and (object? object)
       (memq class (class-ancestors (object-class object)))))

;;;;
;;;; CONSTRUCTORS
;;;;

(define (new class . args)
  (define constructor (class-constructor class))
  (if constructor
      (apply constructor args)
      (error "Can't create instance of class because it is abstract" class)))

(define (make-constructor class arg-names)
  (define arg-indicies (map (lambda (arg)
			      (field-index arg  class))
			    arg-names))
  (define arg-count (length arg-names))
  (define field-count
    (length (class-fields class)))
  (define (constructor . args)
    (define new-object
      (%make-object class
		    (apply vector
			   (class-field-default-values class))))
    (unless (eq? (length args) arg-count)
      (error "Wrong number of arguments in constructor for " class args arg-names))
    (let ((fields (object-fields new-object)))
      (for-each (lambda (index value)
		  (vector-set! fields index value))
		arg-indicies
		args))
    (initialize! new-object)
    new-object)

  constructor)

;;;;
;;;; SYNTAX
;;;;

(define-syntax define-class
  (syntax-rules ()
    ((define-class ?name ?parent ?clauses ...)
     (define-class-internal ?name ?parent (?clauses ...)
       #f () ()))))

(define-syntax define-class-internal
  (syntax-rules (fields methods args)
    ((define-class-internal ?child ?parent
       ((args ?constructor-arg ...) other-stuff ...) #f ?fields ?methods)
     (define-class-internal ?child ?parent
       (other-stuff ...) (?constructor-arg ...) ?fields ?methods))

    ((define-class-internal ?child ?parent
       ((fields ?field ...) other-stuff ...) ?constructor-args () ?methods)
     (define-class-internal ?child ?parent
       (other-stuff ...) ?constructor-args (?field ...) ?methods))

    ((define-class-internal ?child ?parent
       ((methods ?method ...) other-stuff ...) ?constructor-args ?fields ())
     (define-class-internal ?child ?parent
       (other-stuff ...) ?constructor-args ?fields (?method ...)))

    ((define-class-internal ?child ?parent
       () ?constructor-args (?field ...) (?method ...))
     (begin (define ?child (make-class '?child ?parent
				       '?constructor-args
				       (list (field-info ?field) ...)
				       (list (method-info ?method) ...)))
	    (make-accessor ?field ?child) ...
	    (make-generic-wrapper ?method ?child) ...))))

(define-syntax make-generic-wrapper
  (syntax-rules ()
    ((make-generic-wrapper (?method ?stuff ...) ?child)
     (define ?method (object-generic ?child '?method)))
    ((make-generic-wrapper ?method ?child)
     (define ?method (object-generic ?child '?method)))))

(define-syntax make-accessor
  (syntax-rules ()
    ((make-accessor (?name ?other-args ...) ?class)
     (define ?name (object-accessor ?class '?name)))
    ((make-accessor ?name ?class)
     (define ?name (object-accessor ?class '?name)))))    

(define-syntax define-method
  (syntax-rules ()
    ((define-method (name (object class) args ...) body ...)
     (set-method! class 'name
		  (let ((generic name))
		    (lambda (object args ...)
		      body ...))))))

;;;;
;;;; THE OBJECT CLASS
;;;;

(define object
  (%make-class 'object
	       #f
	       '()
	       #f
	       '()
	       (list (make-method 'initialize! #f '() #f))
	       (vector (lambda (x) #f))
	       '()
	       #f))
(set-class-ancestors! object (list object))

(define initialize!
  (object-generic object 'initialize!))

;;;;
;;;; UTILITIES
;;;;

(define (dec o)
  (zip (map field-name (class-fields (object-class o)))
       (vector->list (object-fields o))))